{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit InputQuestion;

interface

uses
  Classes, SysUtils, MiscUtils, WildcardMatcher, RegExpr, TestCore, TestUtils;

type
  TPattern = class
  public
    constructor Create; virtual;
    function Match(const CandidateText: UnicodeString): Single; virtual; abstract;
    function GetValue: UnicodeString; virtual; abstract;
    function ReplaceString(const OldString, NewString: String): Integer; virtual; abstract;
    function Clone: TPattern;
    procedure Assign(Source: TPattern); virtual;
  end;
  TPatternClass = class of TPattern;
  TPatternList = TGenericObjectList<TPattern>;

  TTextPattern = class(TPattern)
  private
    FValue: UnicodeString;
    FQuality: Single;
    FCaseSensitive: Boolean;
    FNumericAware: Boolean;
    FWildcard: Boolean;
    FSpaceDelimited: Boolean;
    FPrecision: String;
    procedure SetQuality(Value: Single);
    procedure SetPrecision(const Value: String);
    function MatchWord(CandidateWord, CorrectWord: UnicodeString): Boolean;
  public
    constructor Create; override;
    function Match(const CandidateText: UnicodeString): Single; override;
    function GetValue: UnicodeString; override;
    function ReplaceString(const OldString, NewString: String): Integer; override;
    procedure Assign(Source: TPattern); override;

    property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive;
    property NumericAware: Boolean read FNumericAware write FNumericAware;
    property Precision: String read FPrecision write SetPrecision;
    property Quality: Single read FQuality write SetQuality;
    property SpaceDelimited: Boolean read FSpaceDelimited write FSpaceDelimited;
    property Value: UnicodeString read FValue write FValue;
    property Wildcard: Boolean read FWildcard write FWildcard;
  end;

  TRegexpProcessor = class
  private
    FEngine: TRegExpr;
    class function InvertCase(const Ch: REChar): REChar;
  public
    constructor Create(const Regexp: UnicodeString; SegmentStart, SegmentLength: Integer; CaseSensitive: Boolean);
    destructor Destroy; override;
    function Execute(const s: UnicodeString): Boolean;
  end;

  TRegexpPattern = class(TPattern)
  private
    FValue: UnicodeString;
    FQuality: Single;
    FCaseSensitive: Boolean;
    FPreprocessSpaces: Boolean;
    FNormalizeSpaces: Boolean; { meaningful when FPreprocessSpaces = TRUE }
    FProcessor: TRegexpProcessor;
    procedure SetQuality(Value: Single);
    procedure SetValue(const Value: UnicodeString);
    procedure SetCaseSensitive(Value: Boolean);
  public
    destructor Destroy; override;
    function Match(const CandidateText: UnicodeString): Single; override;
    function GetValue: UnicodeString; override;
    function ReplaceString(const OldString, NewString: String): Integer; override;
    procedure Assign(Source: TPattern); override;

    property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
    property NormalizeSpaces: Boolean read FNormalizeSpaces write FNormalizeSpaces;
    property PreprocessSpaces: Boolean read FPreprocessSpaces write FPreprocessSpaces;
    property Quality: Single read FQuality write SetQuality;
    property Value: UnicodeString read FValue write SetValue;
  end;

  TInputResponse = class(TResponse)
  private
    FAnswer: UnicodeString;
    procedure SetAnswer(const Value: UnicodeString);
  public
    procedure Assign(Source: TResponse); override;

    property Answer: UnicodeString read FAnswer write SetAnswer;
  end;

  TInputQuestion = class(TQuestionWithFormulation)
  private
    FPatterns: TPatternList;
    function GetPatternCount: Integer;
    function GetPatterns(Index: Integer): TPattern;
  public
    constructor Create; override;
    destructor Destroy; override;
    class function GetResponseClass: TResponseClass; override;
    class function GetMaxAnswerLength: Integer;
    class procedure Spawn(var Question: TQuestion; Alterants: TAlterantList); override;
    class function LaxEvaluationByDefault: Boolean; override;
    class function Kind: TKind; override;
    function IsResponseCompatible(Candidate: TResponse): Boolean; override;
    function Evaluate(Candidate: TResponse): Single; override;
    procedure Filter; override;
    procedure Assign(Source: TQuestion); override;
    procedure Add(Pattern: TPattern);
    function ReplaceString(const OldString, NewString: String): Integer; override;
    function Response: TInputResponse;

    property PatternCount: Integer read GetPatternCount;
    property Patterns[Index: Integer]: TPattern read GetPatterns;
  end;

  TSpawnInputQuestionAlterant = class(TAlterant)
  public
    procedure Apply(var Question: TQuestion); override;
  end;

implementation

resourcestring
  SAnswerLengthExceeded = 'The answer length exceeds the limit (%d).';
  SRegexpProcessingError = 'Regular expression processing error: %s';
  SBadAnswerCharacter = 'Illegal character encountered in answer.';

const
  MAX_ANSWER_LENGTH = 200;

{ TInputQuestion }

constructor TInputQuestion.Create;
begin
  inherited;
  FPatterns := TPatternList.Create;
end;

destructor TInputQuestion.Destroy;
begin
  FreeAndNil(FPatterns);
  inherited;
end;

function TInputQuestion.IsResponseCompatible(
  Candidate: TResponse): Boolean;
begin
  Result := Candidate is TInputResponse;
end;

function TInputQuestion.Evaluate(Candidate: TResponse): Single;
var
  CandidateAnswer: UnicodeString;
  p: TPattern;
begin
  CheckResponseCompatible(Candidate);
  CandidateAnswer := TInputResponse(Candidate).Answer;

  Result := 0;
  for p in FPatterns do
  begin
    Result := p.Match(CandidateAnswer);
    if Result > 0 then
      Break;
  end;

  if not LaxEvaluation and (Result < 1) then
    Result := 0; 
end;

procedure TInputQuestion.Filter;
begin
  inherited;
  FPatterns.Clear;
  Response.Clear;
end;

class function TInputQuestion.GetMaxAnswerLength: Integer;
begin
  Result := MAX_ANSWER_LENGTH;
end;

function TInputQuestion.Response: TInputResponse;
begin
  Result := TInputResponse(inherited);
end;

function TInputQuestion.GetPatternCount: Integer;
begin
  Result := FPatterns.Count;
end;

function TInputQuestion.GetPatterns(Index: Integer): TPattern;
begin
  Assert( Index >= 0 );
  Assert( Index < PatternCount );
  Result := FPatterns[Index];
end;

class function TInputQuestion.GetResponseClass: TResponseClass;
begin
  Result := TInputResponse;
end;

procedure TInputQuestion.Assign(Source: TQuestion);
var
  q: TInputQuestion;
  p: TPattern;
begin
  inherited;
  q := Source as TInputQuestion;

  FPatterns.Clear;
  for p in q.FPatterns do
    FPatterns.AddSafely(p.Clone);
end;

procedure TInputQuestion.Add(Pattern: TPattern);
begin
  FPatterns.AddSafely(Pattern);
end;

function TInputQuestion.ReplaceString(const OldString, NewString: String): Integer;
var
  ReplaceCount: Integer;
  p: TPattern;
begin
  Result := inherited;

  Response.Answer := UTF8Decode(ReplacePattern(UTF8Encode(Response.Answer),
    OldString, NewString, ReplaceCount));
  Inc(Result, ReplaceCount);

  for p in FPatterns do
    Inc(Result, p.ReplaceString(OldString, NewString));
end;

class procedure TInputQuestion.Spawn(var Question: TQuestion;
  Alterants: TAlterantList);
var
  Alterant: TSpawnInputQuestionAlterant;
begin
  inherited;
  Alterant := TSpawnInputQuestionAlterant.Create;
  Alterants.Add(Alterant);
  Alterant.Apply(Question);
end;

class function TInputQuestion.LaxEvaluationByDefault: Boolean;
begin
  Result := TRUE;
end;

class function TInputQuestion.Kind: TKind;
begin
  Result := $602479266c77df36;
end;

{ TInputResponse }

procedure TInputResponse.Assign(Source: TResponse);
begin
  inherited;
  FAnswer := (Source as TInputResponse).FAnswer;
  Changed;
end;

procedure TInputResponse.SetAnswer(const Value: UnicodeString);
begin
  if FAnswer <> Value then
  begin
    if Length(Value) > MAX_ANSWER_LENGTH then
      raise Exception.CreateFmt(SAnswerLengthExceeded, [MAX_ANSWER_LENGTH]);
    if Pos(#0, Value) > 0 then
      raise Exception.Create(SBadAnswerCharacter);
    FAnswer := Value;
    Changed;
  end;
end;

{ TTPattern }

constructor TPattern.Create;
begin
  inherited;
  { do nothing }
end;

function TPattern.Clone: TPattern;
begin
  Result := TPatternClass(ClassType).Create;
  try
    Result.Assign(Self);
  except
    Result.Free;
    raise;
  end;
end;

procedure TPattern.Assign(Source: TPattern);
begin
  Assert( ClassType = Source.ClassType );
end;

{ TTextPattern }

procedure TTextPattern.Assign(Source: TPattern);
var
  p: TTextPattern;
begin
  inherited;
  p := Source as TTextPattern;

  FValue := p.FValue;
  FQuality := p.FQuality;
  FCaseSensitive := p.FCaseSensitive;
  FNumericAware := p.FNumericAware;
  FWildcard := p.FWildcard;
  FSpaceDelimited := p.FSpaceDelimited;
  FPrecision := p.FPrecision;
end;

function TTextPattern.Match(const CandidateText: UnicodeString): Single;
var
  CandidateWords, CorrectWords: TUnicodeStringList;
  i: Integer;
begin
  if FSpaceDelimited then
  begin
    CandidateWords := TUnicodeStringList.Create;
    try
      SplitUnicodeString(CandidateText, ' ', CandidateWords);
      CorrectWords := TUnicodeStringList.Create;
      try
        SplitUnicodeString(FValue, ' ', CorrectWords);

        if CandidateWords.Count = CorrectWords.Count then
        begin
          Result := Quality;
          for i := 0 to CandidateWords.Count-1 do
            if not MatchWord(CandidateWords[i], CorrectWords[i]) then
            begin
              Result := 0;
              Break;
            end;
        end
        else
          Result := 0;
      finally
        CorrectWords.Free;
      end;
    finally
      CandidateWords.Free;
    end;
  end
  else
    if MatchWord(CutUnicodeCharacters(CandidateText, ' '), CutUnicodeCharacters(FValue, ' ')) then
      Result := Quality
    else
      Result := 0;
end;

function TTextPattern.MatchWord(CandidateWord, CorrectWord: UnicodeString): Boolean;
var
  CandidateNumber, CorrectNumber, Delta: TFixedPointDecimal;
  ResultValid: Boolean;
begin
  ResultValid := FALSE;

  if FNumericAware then
  begin
    CandidateNumber := TFixedPointDecimal.Parse(UTF8Encode(CandidateWord));
    try
      if CandidateNumber <> nil then
      begin
        CorrectNumber := TFixedPointDecimal.Parse(UTF8Encode(CorrectWord));
        try
          if CorrectNumber <> nil then
          begin
            Delta := TFixedPointDecimal.Parse(FPrecision);
            try
              Assert( Delta <> nil );
              Result := CorrectNumber.IsNearby(CandidateNumber, Delta);
              ResultValid := TRUE;
            finally
              Delta.Free;
            end;
          end;
        finally
          CorrectNumber.Free;
        end;
      end;
    finally
      CandidateNumber.Free;
    end;
  end;

  if not ResultValid then
  begin
    if not FCaseSensitive then
    begin
      CandidateWord := UnicodeUpperCase(CandidateWord);
      CorrectWord := UnicodeUpperCase(CorrectWord);
    end;

    if FWildcard then
      Result := UnicodeStrMatches(CorrectWord, CandidateWord)
    else
      Result := CorrectWord = CandidateWord;
  end;
end;

function TTextPattern.ReplaceString(const OldString, NewString: String): Integer;
begin
  FValue := UTF8Decode(ReplacePattern(UTF8Encode(FValue),
    OldString, NewString, Result));
end;

constructor TTextPattern.Create;
begin
  inherited;
  FPrecision := '0';
end;

procedure TTextPattern.SetPrecision(const Value: String);
begin
  Assert( TFixedPointDecimal.IsValidNonNegative(Value) );
  FPrecision := Value;
end;

procedure TTextPattern.SetQuality(Value: Single);
begin
  Assert( Value >= 0 );
  Assert( Value <= 1 );
  FQuality := Value;
end;

function TTextPattern.GetValue: UnicodeString;
begin
  Result := FValue;
end;

{ TSpawnInputQuestionAlterant }

procedure TSpawnInputQuestionAlterant.Apply(var Question: TQuestion);
var
  q: TInputQuestion;
begin
  Assert( Question is TInputQuestion );
  q := TInputQuestion(Question);

  if q.PatternCount > 0 then
    q.Response.Answer := q.Patterns[0].GetValue
  else
    q.Response.Answer := '';
end;

{ TRegexpPattern }

procedure TRegexpPattern.Assign(Source: TPattern);
var
  p: TRegexpPattern;
begin
  inherited;
  p := Source as TRegexpPattern;

  FValue := p.FValue;
  FQuality := p.FQuality;
  FCaseSensitive := p.FCaseSensitive;
  FPreprocessSpaces := p.FPreprocessSpaces;
  FNormalizeSpaces := p.FNormalizeSpaces;

  FreeAndNil(FProcessor);
end;

function TRegexpPattern.Match(const CandidateText: UnicodeString): Single;
var
  s: UnicodeString;
begin
  try
    if FPreprocessSpaces then
    begin
      if FNormalizeSpaces then
        s := CollapseUnicodeSpaces(CandidateText)
      else
        s := CutUnicodeCharacters(CandidateText, ' ');
    end
    else
      s := CandidateText;

    if FProcessor = nil then
      FProcessor := TRegexpProcessor.Create(
        ShiftRegexpBackReferences('\A(' + FValue + ')\Z'), 4, Length(FValue), FCaseSensitive);

    if FProcessor.Execute(s) then
      Result := Quality
    else
      Result := 0;
  except on E: Exception do
    raise Exception.CreateFmt(SRegexpProcessingError, [E.Message]);
  end;
end;

function TRegexpPattern.ReplaceString(const OldString, NewString: String): Integer;
begin
  Value := UTF8Decode(ReplacePattern(UTF8Encode(FValue),
    OldString, NewString, Result));
end;

procedure TRegexpPattern.SetCaseSensitive(Value: Boolean);
begin
  if FCaseSensitive <> Value then
  begin
    FreeAndNil(FProcessor);
    FCaseSensitive := Value;
  end;
end;

procedure TRegexpPattern.SetQuality(Value: Single);
begin
  Assert( Value >= 0 );
  Assert( Value <= 1 );
  FQuality := Value;
end;

procedure TRegexpPattern.SetValue(const Value: UnicodeString);
begin
  if FValue <> Value then
  begin
    FreeAndNil(FProcessor);
    FValue := Value;
  end;
end;

function TRegexpPattern.GetValue: UnicodeString;
begin
  Result := FValue;
end;

destructor TRegexpPattern.Destroy;
begin
  FreeAndNil(FProcessor);
  inherited;
end;

{ TRegexpProcessor }

class function TRegexpProcessor.InvertCase(const Ch: REChar): REChar;
var
  s, r: UnicodeString;
begin
  s := Ch;
  r := UnicodeUpperCase(s);
  if r = s then
    r := UnicodeLowerCase(s);
  Assert( Length(r) = 1 );
  Result := r[1];
end;

constructor TRegexpProcessor.Create(const Regexp: UnicodeString; SegmentStart, SegmentLength: Integer;
  CaseSensitive: Boolean);
begin
  inherited Create;
  if not ContainsUnicodeZeroCharacter(Regexp) then
  begin
    FEngine := TRegExpr.Create;
    FEngine.InvertCase := InvertCase;
    FEngine.ModifierI := not CaseSensitive;
    FEngine.Expression := Regexp;
    FEngine.SegmentStart := SegmentStart;
    FEngine.SegmentLength := SegmentLength;
  end;
end;

destructor TRegexpProcessor.Destroy;
begin
  FreeAndNil(FEngine);
  inherited;
end;

function TRegexpProcessor.Execute(const s: UnicodeString): Boolean;
begin
  if (FEngine <> nil) and not ContainsUnicodeZeroCharacter(s) then
    Result := FEngine.Exec(s)
  else
    Result := FALSE;
end;

end.

